home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / ada_met1.zip / EXECUTE.ADA < prev    next >
Text File  |  1989-06-25  |  13KB  |  387 lines
  1. ------------------------------------------------------------------------------
  2. --
  3. --  Separate Unit    -      EXECUTE
  4. --
  5. --    This file contains the routine EXECUTE.  Given an AST
  6. --    operator node which has its operand defined, this routine will
  7. --    execute that operator (and any operators beneath it) and alter
  8. --    the AST to reflect the result.
  9. --
  10. --    It is possible that an error will creep in and the operands will
  11. --    not be of the appropriate types.    In this case notify the user of
  12. --    the error.  If thorough type-checking were included in the parser
  13. --    then the only way this error could arise would be through
  14. --    variable bindings.
  15. --
  16. ------------------------------------------------------------------------------
  17.  
  18. separate(prover)
  19.  
  20.  
  21. procedure execute (operator : in out AST_ptr;
  22.            bindings : in out binding_list;
  23.            level    :         natural;
  24.            failed   : in out boolean      ) is
  25. temp : AST_ptr := null;
  26. is_int_1, is_int_2, use_threshold : boolean := false;
  27. matched, unified : boolean;
  28. int_result, trash : integer;
  29. rcs_1, rcs_2, rcs_result : long_float; --!!! was float
  30. radar_1, radar_2, radar_result : radar_values;
  31. left_value, right_value : argument_ptr;
  32. temp_bindings : binding_list;
  33.  
  34. package arg_io   is new enumeration_io(argument_type);  use arg_io;    --!!!
  35. package token_io is new enumeration_io(token_type   );  use token_io;  --!!!
  36. package node_io  is new enumeration_io(AST_node_type);  use node_io;   --!!!
  37.  
  38. procedure binary_arithmetic is
  39. begin
  40.     lookup(operator.left_operand,  level, bindings, left_value,  trash);
  41.     lookup(operator.right_operand, level, bindings, right_value, trash);
  42.  
  43.   if (left_value.is_a = integer_num) and (right_value.is_a = integer_num) then
  44.  
  45.     if    operator.binary_op = asterisk then
  46.         int_result := left_value.int_num  *  right_value.int_num;
  47.  
  48.     elsif operator.binary_op = minus    then
  49.         int_result := left_value.int_num  -  right_value.int_num;
  50.  
  51.     elsif operator.binary_op = rw_mod   then
  52.         int_result := left_value.int_num mod right_value.int_num;
  53.  
  54.     elsif operator.binary_op = plus     then
  55.         int_result := left_value.int_num  +  right_value.int_num;
  56.  
  57.     else
  58.         int_result := left_value.int_num  /  right_value.int_num;
  59.     end if;
  60.         temp := new AST'(integer_num, int_result);
  61.     else
  62.     if left_value.is_a = integer_num then
  63.         rcs_1 := long_float(left_value.int_num);  --!!! was float
  64.     elsif left_value.is_a = float_num then
  65.         rcs_1 := left_value.rcs_num;
  66.     else
  67.             error(no_pointer,"invalid type to arithmetic operator");
  68.         failed := true;
  69.     end if;
  70.     if right_value.is_a = integer_num then
  71.         rcs_2 := long_float(right_value.int_num);  --!!! was float
  72.     elsif right_value.is_a = float_num then
  73.         rcs_2 := right_value.rcs_num;
  74.     else
  75.             error(no_pointer,"invalid type to arithmetic operator");
  76.         failed := true;
  77.     end if;
  78.     if not failed then
  79.         if operator.binary_op = asterisk then
  80.         rcs_result := rcs_1 * rcs_2;
  81.         elsif operator.binary_op = minus then
  82.         rcs_result := rcs_1 - rcs_2;
  83.         elsif operator.binary_op = rw_mod then
  84.                 error(no_pointer,"'mod' only valid for integer arguments");
  85.         failed := true;
  86.         elsif operator.binary_op = plus  then
  87.         rcs_result := rcs_1 + rcs_2;
  88.         else
  89.         rcs_result := rcs_1 / rcs_2;
  90.         end if;
  91.         if not failed then
  92.                 temp := new AST'(float_num, rcs_result);
  93.         end if;
  94.     end if;
  95.     end if;
  96. end binary_arithmetic;
  97.  
  98. procedure binary_logic is
  99. begin
  100.     if operator.left_operand.node_type = radar_value then
  101.     radar_1 := operator.left_operand.radar_num;
  102.     elsif operator.left_operand.node_type = threshold_marker then
  103.     radar_1 := operator.left_operand.radar_value;
  104.     threshold := operator.left_operand.threshold;
  105.     use_threshold := true;
  106.     else
  107.     failed := true;
  108.         put("Error -- radar operator ");put(operator.binary_op);
  109.         put(" given invalid operand of type ");
  110.     put(operator.left_operand.node_type);  new_line;
  111.     end if;
  112.     if operator.right_operand.node_type = radar_value then
  113.     radar_2 := operator.right_operand.radar_num;
  114.     elsif operator.right_operand.node_type = threshold_marker then
  115.     radar_2 := operator.right_operand.radar_value;
  116.     threshold := operator.right_operand.threshold;
  117.     use_threshold := true;
  118.     else
  119.     failed := true;
  120.         put("Error -- radar operator ");put(operator.binary_op);
  121.         put(" given invalid operand of type ");
  122.     put(operator.right_operand.node_type);    new_line;
  123.     end if;
  124. --
  125.     if failed then
  126.     radar_result := 0.0;
  127.     else
  128.     if operator.binary_op = bar then
  129.         --
  130.         --    The following line is an implementation of the
  131.         --    combining of two radar values
  132.         --
  133.         rcs_result := radar_1 * radar_2 - (radar_1 * radar_2);
  134.         --
  135.         --    Occasionally borderline inaccuracies in floating point
  136.         --    arithmetic cause a result greater than one, which in
  137.         --    turn causes a constraint error
  138.         --
  139.         if rcs_result > 1.0 then
  140.         radar_result := 1.0;
  141.         else
  142.         radar_result := rcs_result;
  143.         end if;
  144.     elsif operator.binary_op = comma then
  145.         if radar_1 < radar_2 then
  146.         radar_result := radar_1;
  147.         else
  148.         radar_result := radar_2;
  149.         end if;
  150.     elsif operator.binary_op = hat then
  151.         radar_result := radar_1 * radar_2;
  152.     else          --      op = semicolon
  153.         if radar_1 > radar_2 then
  154.         radar_result := radar_1;
  155.         else
  156.         radar_result := radar_2;
  157.         end if;
  158.     end if;
  159.     end if;
  160. --
  161.     if use_threshold then
  162.         temp := new AST'(threshold_marker, radar_result, threshold);
  163.     else
  164.         temp := new AST'(radar_value, radar_result);
  165.     end if;
  166.     current_truth := radar_result;
  167. end binary_logic;
  168.  
  169.  
  170. procedure binding_comparator is
  171. begin
  172.     temp_bindings := bindings;
  173.     unify_arg(operator.left_operand, operator.right_operand, level,
  174.           level, temp_bindings, unified);
  175.     if (unified xor (operator.binary_op /= not_equal)) then
  176.         temp := new AST'(radar_value, 0.0);
  177.     current_truth := 0.0;
  178.     failed := true;
  179.     else
  180.         temp := new AST'(radar_value, 1.0);
  181.     current_truth := 1.0;
  182.     end if;
  183.     if not (operator.binary_op = not_equal) then       -- save the bindings
  184.     bindings := temp_bindings;
  185.     end if;
  186. end binding_comparator;
  187.  
  188.  
  189. procedure comparator is
  190. begin
  191.     lookup(operator.left_operand  , level, bindings, left_value,  trash);
  192.     lookup(operator.right_operand , level, bindings, right_value, trash);
  193.     if (left_value.is_a = right_value.is_a) or
  194.        ((left_value.is_a = integer_num) and (right_value.is_a = float_num)) or
  195.        ((left_value.is_a = float_num  ) and (right_value.is_a = integer_num))
  196.       then
  197.     case left_value.is_a is
  198.       when predicate =>
  199.         if (operator.binary_op = equality     ) or
  200.            (operator.binary_op = not_equality) then
  201.         matched := left_value.name.name = right_value.name.name;
  202.         elsif operator.binary_op = less_than then
  203.         matched := left_value.name.name < right_value.name.name;
  204.         elsif operator.binary_op = greater_than then
  205.         matched := left_value.name.name > right_value.name.name;
  206.         elsif operator.binary_op = less_or_equal then
  207.         matched := left_value.name.name <= right_value.name.name;
  208.         else     --      op = greater_or_equal
  209.         matched := left_value.name.name >= right_value.name.name;
  210.         end if;
  211.       when variable =>
  212.         if (operator.binary_op = equality     ) or
  213.            (operator.binary_op = not_equality) then
  214.         matched := (left_value.v_name.name = right_value.v_name.name);
  215.         else
  216.                 error(no_pointer,"uninstantiated variable to <,<=,>,>=");
  217.         failed := true;
  218.         end if;
  219.       when integer_num | float_num =>
  220.         if left_value.is_a = integer_num then
  221.         rcs_1 := long_float(left_value.int_num);  --!!! was float
  222.         else
  223.         rcs_1 :=       left_value.rcs_num;
  224.         end if;
  225.         if right_value.is_a = integer_num then
  226.         rcs_2 := long_float(right_value.int_num);  --!!! was float
  227.         else
  228.         rcs_2 :=       right_value.rcs_num;
  229.         end if;
  230.         if (operator.binary_op = equality     ) or
  231.            (operator.binary_op = not_equality) then
  232.         matched := rcs_1 = rcs_2;
  233.         elsif oper